home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / debug / byte-code-test.scm next >
Text File  |  1995-10-13  |  2KB  |  77 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Test various of the byte-codes
  5.  
  6. ;(let ((system (make-system '("~/s48/x48/boot/byte-code-test.scm") 'resume #f)))
  7. ;  (write-system system "~/s48/x48/boot/byte-code-test.image"))
  8.  
  9. (define *tests* '())
  10. (define *output-port* #f)
  11.  
  12. (define (make-test . args)
  13.   (set! *tests* (cons args *tests*)))
  14.  
  15. (define (run-test string compare result proc)
  16.   (write-string string *output-port*)
  17.   (write-string "..." *output-port*)
  18.   (force-output *output-port*)
  19.   (write-string (if (compare (proc) result) "OK" "failed") *output-port*)
  20.   (write-char #\newline *output-port*))
  21.  
  22. (make-test "testing test mechanism" (lambda (x y) (eq? x y)) 0 (lambda () 0))
  23. (make-test "primitive catch and throw" (lambda (x y) (eq? x y)) 10
  24.        (lambda ()
  25.          (* 10 (primitive-catch (lambda (k)
  26.                       (my-primitive-throw k 1)
  27.                       (message "after throw???")
  28.                       2)))))
  29.  
  30.  
  31. (define (my-primitive-throw cont value)
  32.   (with-continuation cont (lambda () value)))
  33.  
  34. (define (message string)
  35.   (write-string string *output-port*)
  36.   (write-char #\newline *output-port*))
  37.  
  38. (define (resume arg in out)
  39.   (set! *output-port* out)
  40.   (do ((tests (do ((tests *tests* (cdr tests))
  41.            (r '() (cons (car tests) r)))
  42.           ((eq? '() tests) r))
  43.           (cdr tests)))
  44.       ((eq? '() tests))
  45.     (apply run-test (car tests)))
  46.   (write-string "done" *output-port*)
  47.   (write-char #\newline *output-port*)
  48.   (halt 0))
  49.  
  50. (define *initial-bindings* '())
  51.  
  52. (define (initial-env name)
  53.   (let ((probe (assq name *initial-bindings*)))
  54.     (if probe (cdr probe) (error "unbound" name))))
  55.  
  56. (define (define-initial name val)
  57.   (let* ((probe (assq name *initial-bindings*))
  58.      (loc (if probe
  59.           (cdr probe)
  60.           (let ((loc (make-undefined-location name)))
  61.             (set! *initial-bindings*
  62.               (cons (cons name loc) *initial-bindings*))
  63.             loc))))
  64.     ;; (set-location-defined?! loc #t)  - obsolescent?
  65.     (set-contents! loc val)))
  66.  
  67. (for-each (lambda (name val)
  68.         (define-initial name val))
  69.           '(    cons car cdr + - * < = > list map append reverse)
  70.       (list cons car cdr + - * < = > list map append reverse))
  71.  
  72. (make-test "little env-lookup test" eq? car
  73.        (lambda ()
  74.          (contents (initial-env 'car))))
  75.  
  76. (define (error string . stuff) (message string))
  77.